home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / JReq / demo_req next >
Encoding:
Text File  |  1991-09-21  |  2.5 KB  |  106 lines
  1. \ Demonstrate use of REQ.LIBRARY color pallette.
  2. \
  3. \ Color Requester specific code is marked with a %RQ
  4. \ to find that code just search for %RQ
  5. \
  6. \ Author:  Phil Burk
  7. \ Copyright 1990 Delta Research
  8.  
  9. decimal
  10. INCLUDE? NewWindow.Setup JU:AMIGA_GRAPH
  11. include? sc_Viewport ji:intuition/intuition.j
  12. INCLUDE? NewScreen.Setup JU:SCREEN_SUPPORT
  13. INCLUDE? ?CLOSEBOX JU:AMIGA_EVENTS
  14. include? msec ju:msec
  15. include? choose ju:random
  16.  
  17. include? ColorRequester() jreq:req_support.f   \ %RQ
  18.  
  19. ANEW TASK-DEMO_REQ
  20.  
  21. decimal
  22.  
  23. \ Declare necessary Amiga 'C' structures.
  24. NewScreen req-NewScreen
  25. NewWindow req-NewWindow
  26.  
  27. VARIABLE req-SCREEN
  28.  
  29. : req.INIT.SCREEN ( -- screen | NULL )
  30.      gr.init   
  31. \ Set to default values.
  32.      req-NewScreen NewScreen.Setup
  33.      req-NewWindow NewWindow.Setup
  34. \
  35. \ Modify defaults for this demo.
  36.      4 req-NewScreen s! ns_Depth  ( 16 colors )
  37. \
  38. \ Open Screen and store pointer in NewWindow structure.
  39.      req-NewScreen openscreen() dup req-Screen !  ( Open screen. )
  40. \
  41. \ Sometimes the Amiga can build a bad COPPER list for screens.
  42. \ This can happen if you have Emacs and Workbench up in INTERLACE
  43. \ mode and open a NON-INTERLACE screen.
  44. \ The following calls will correct this problem (hopefully).
  45.     req-screen @ screentoback()
  46.     RemakeDisplay()
  47.     req-screen @ screentofront()
  48. ;
  49.  
  50. : req.INIT.WINDOW ( screen -- window | NULL )
  51.      req-NewWindow s! nw_screen
  52. \
  53. \ Set up window.
  54.      0" req - JForth - Delta Research"
  55.          req-NewWindow s! nw_Title
  56.      CUSTOMSCREEN   req-NewWindow s! nw_type
  57.      req-NewWindow s@ nw_Flags ACTIVATE |
  58.         req-NewWindow s! nw_Flags
  59.      20    req-NewWindow s! nw_TopEdge
  60.      320  req-NewWindow s! nw_Width
  61.      160  req-NewWindow s! nw_Height
  62.      req-NewWindow gr.opencurw
  63. \
  64. \ set window pointer for REQ  \ %RQ
  65.     ?dup
  66.     IF
  67.         dup set.windowptr old-windowptr !
  68.     THEN
  69. ;
  70.  
  71. : req.TERM ( -- , CLose demo screen )
  72. \ clear windowptr to avoid terrible crash , maybe...  %RQ
  73.     old-windowptr @ set.windowptr drop
  74. \
  75.     gr.closecurw
  76.     req-screen @ closescreen()
  77. ;
  78.  
  79. variable req-#COLORS
  80. : req.DRAW.STUFF ( -- , draw colored boxes )
  81.     1 req-NewScreen s@ ns_depth shift
  82.     dup req-#colors !
  83.     2
  84.     DO i gr.color!
  85.        5 i 14 * +
  86.        5
  87.        over 14 +
  88.        120
  89.        gr.rect
  90.     LOOP
  91. ;
  92.     
  93. : DEMO.req  ( -- , cycle colors with random source )
  94.     req?
  95.     req.init.screen ?dup
  96.     IF  req.init.window
  97.         IF  req.draw.stuff
  98.             0 ColorRequester() drop    \ %RQ    that's all....
  99.             req.term
  100.         THEN
  101.     THEN
  102.     -req
  103. ;
  104.  
  105. cr ." Enter:    DEMO.REQ" cr
  106.